home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / print.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-06-09  |  8.4 KB  |  328 lines
  1. /*
  2.  * p r i n t . c                -- writing stuff
  3.  *
  4.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5.  * 
  6.  *
  7.  * Permission to use, copy, and/or distribute this software and its
  8.  * documentation for any purpose and without fee is hereby granted, provided
  9.  * that both the above copyright notice and this permission notice appear in
  10.  * all copies and derived works.  Fees for distribution or use of this
  11.  * software or derived works may only be charged with express written
  12.  * permission of the copyright holder.  
  13.  * This software is provided ``as is'' without express or implied warranty.
  14.  *
  15.  * This software is a derivative work of other copyrighted softwares; the
  16.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  17.  *
  18.  *           Author: Erick Gallesio [eg@unice.fr]
  19.  *    Creation date: ??-Oct-1993 ??:?? 
  20.  * Last file update:  9-Jun-1996 23:53
  21.  *
  22.  */
  23.  
  24. #include "stk.h"
  25. #include "extend.h"
  26.  
  27. static char valid_symbol_chars[]=
  28.         "abcdefghijklmnopqrstuvwxyz0123456789+-.*/<=>!?:$%_&~^";
  29.  
  30. static void printlist(SCM exp, SCM port, int mode)
  31. {
  32.   SCM tmp;
  33.   FILE *f = PORT_FILE(port);
  34.  
  35.   STk_print(CAR(exp), port, mode);
  36.   for (tmp=CDR(exp); CONSP(tmp); tmp=CDR(tmp)) {
  37.     Putc(' ', f);
  38.     STk_print(CAR(tmp), port, mode);
  39.   }
  40.   if (NNULLP(tmp)) {
  41.     Puts(" . ", f);
  42.     STk_print(tmp, port, mode);
  43.   }
  44. }
  45.  
  46. static void printsymbol(char *s, FILE *f, int mode)
  47. {
  48.   if (mode==WRT_MODE) {    /* See if we need to enclose pname between a "|" pair */
  49.     register char *p;
  50.     for (p = s; *p; p++) {
  51.       if (!strchr(valid_symbol_chars, *p)) {
  52.     Putc('|', f);  Puts(s, f); Putc('|', f);
  53.     return;
  54.       }
  55.     }
  56.   }
  57.   Puts(s, f);
  58. }
  59.  
  60. #ifdef USE_STKLOS
  61. static void display_instance(SCM instance, SCM port, int type)
  62. {
  63.   char *fct_name;
  64.  
  65.   if (type == DSP_MODE)   fct_name = "display-object"; else
  66.   if (type == WRT_MODE)   fct_name = "write-object";   else
  67.   /* (type == TK_MODE) */ fct_name = "tk-write-object";
  68.  
  69.   Apply(VCELL(STk_intern(fct_name)), LIST2(instance, port));
  70. }
  71. #endif
  72.  
  73.            
  74. SCM STk_print(SCM exp, SCM port, int mode)
  75. {
  76.   FILE *f = PORT_FILE(port);
  77.  
  78.   switch TYPE(exp) {
  79.     case tc_nil:
  80.       Puts("()", f);
  81.       break;
  82.     case tc_undefined:
  83.       Puts("#[undefined]", f);
  84.       break;
  85.     case tc_boolean:
  86.       Puts(EQ(exp, Truth) ? "#t" : "#f", f);
  87.       break;
  88.     case tc_eof:
  89.       Puts("#[eof]", f);
  90.       break;
  91.     case tc_cons:
  92.       Putc('(', f); printlist(exp, port, mode); Putc(')', f);
  93.       break;
  94.     case tc_integer:
  95.     case tc_bignum:
  96.     case tc_flonum:
  97.       {
  98.     char buffer[100];
  99.  
  100.     char *s = STk_number2Cstr(exp, 10, buffer);
  101.     Puts(s, f);
  102.     if (TYPE(exp) == tc_bignum) free(s);
  103.       }
  104.       break;
  105.     case tc_symbol:
  106.       printsymbol(PNAME(exp), f, mode);
  107.       break;
  108.     case tc_keyword:
  109.       if (mode != DSP_MODE) Putc(':', f);
  110.       Puts(KEYVAL(exp)+1, f);
  111.       break;
  112.     case tc_subr_0:
  113.     case tc_subr_1:
  114.     case tc_subr_2:
  115.     case tc_subr_3:
  116.     case tc_subr_0_or_1:
  117.     case tc_subr_1_or_2:
  118.     case tc_subr_2_or_3:
  119.     case tc_lsubr:
  120.     case tc_ssubr:
  121.     case tc_fsubr:
  122.     case tc_syntax:
  123.       Puts("#[subr ", f);
  124.       Puts((*exp).storage_as.subr.name, f);
  125.       Putc(']', f);
  126.       break;
  127.     case tc_closure:
  128.       if (mode != TK_MODE) 
  129.     sprintf(STk_tkbuffer, "#[closure %lx]", (unsigned long) exp);
  130.       else 
  131.     sprintf(STk_tkbuffer, "#p%lx", (unsigned long) exp);
  132.       Puts(STk_tkbuffer, f);
  133.       break;
  134.     case tc_char:
  135.       if (mode!=DSP_MODE){
  136.     Puts("#\\", f);
  137.     Puts(STk_char2string(CHAR(exp)), f);
  138.       }
  139.       else Putc(CHAR(exp), f);
  140.       break;      
  141.     case tc_string:
  142.       {
  143.     register char *p  = CHARS(exp);
  144.     register int  len = STRSIZE(exp);
  145.  
  146.     if (mode!=DSP_MODE) Putc('"', f);
  147.     
  148.     for (  ; len; len--, p++) {
  149.       if (mode != DSP_MODE)
  150.         switch (*p) {
  151.           case '\0' : Puts("\\0000", f); break;
  152.           case '\a' : Puts("\\a", f); break;
  153.           case '\b' : Puts("\\n", f); break;
  154.           case '\f' : Puts("\\f", f); break;
  155.           case '\n' : Puts("\\n", f); break;
  156.           case '\r' : Puts("\\r", f); break;
  157.           case '\t' : Puts("\\t", f); break;
  158.           case '\v' : Puts("\\v", f); break;
  159.           case '"'  :
  160.           case '\\' : Putc('\\', f); /* NO BREAK */
  161.           default:    Putc(*p, f);
  162.         }
  163.       else 
  164.          Putc(*p, f);
  165.     }
  166.     
  167.     if (mode!=DSP_MODE) Putc('"', f);    
  168.       }
  169.       break;
  170.     case tc_vector:
  171.       {
  172.         int j, n = exp->storage_as.vector.dim;
  173.         
  174.         Puts("#(", f);
  175.         for(j=0; j < n; j++) {
  176.       STk_print(VECT(exp)[j], port, mode);
  177.       if ((j + 1) < n) Putc(' ', f);
  178.     }
  179.         Putc(')', f);
  180.       }
  181.       break;         
  182.     case tc_iport:
  183.       if (mode != TK_MODE) 
  184.     sprintf(STk_tkbuffer, "#[input-port '%s'%s]", PORT_NAME(exp),
  185.                       (PORT_FLAGS(exp) & PORT_CLOSED) ? "(closed)" : "");
  186.       else
  187.     sprintf(STk_tkbuffer, "#file%lx", (unsigned long) exp);
  188.       Puts(STk_tkbuffer, f);
  189.       break;
  190.     case tc_oport:
  191.       if (mode != TK_MODE) 
  192.     sprintf(STk_tkbuffer, "#[output-port '%s'%s]", PORT_NAME(exp),
  193.                       (PORT_FLAGS(exp) & PORT_CLOSED) ? "(closed)" : "");
  194.       else
  195.     sprintf(STk_tkbuffer, "#file%lx", (unsigned long) exp);
  196.       Puts(STk_tkbuffer, f);
  197.       break;
  198.     case tc_isport:
  199.       sprintf(STk_tkbuffer, "#[input-string-port %lx%s]",
  200.           (unsigned long) exp,
  201.           (PORT_FLAGS(port) & PORT_CLOSED) ? "(closed)" : "");
  202.       Puts(STk_tkbuffer, f);
  203.       break;
  204.     case tc_osport:
  205.       sprintf(STk_tkbuffer, "#[output-string-port %lx%s]",
  206.           (unsigned long) exp,
  207.           (PORT_FLAGS(port) & PORT_CLOSED) ? "(closed)" : "");
  208.       Puts(STk_tkbuffer, f);
  209.       break;
  210.     case tc_macro:
  211.       sprintf(STk_tkbuffer, "#[macro %lx]",
  212.           (unsigned long) exp);
  213.       Puts(STk_tkbuffer, f);
  214.       break;
  215.     case tc_localvar:
  216.       sprintf(STk_tkbuffer,"#[local %s @%d,%d)]",
  217.           PNAME(exp->storage_as.localvar.symbol),
  218.           exp->storage_as.localvar.level, 
  219.           exp->storage_as.localvar.position);
  220.       Puts(STk_tkbuffer, f);
  221.       break;
  222.     case tc_globalvar:
  223.       sprintf(STk_tkbuffer, "#[global %s]", PNAME(VCELL(exp)));
  224.       Puts(STk_tkbuffer, f);
  225.       break;
  226.     case tc_cont:
  227.       sprintf(STk_tkbuffer, "#[continuation %lx]", (unsigned long) exp);
  228.       Puts(STk_tkbuffer, f);
  229.       break;
  230.     case tc_env:
  231.       sprintf(STk_tkbuffer, "#[environment %lx]", (unsigned long) exp);
  232.       Puts(STk_tkbuffer, f);
  233.       break;
  234.     case tc_address:
  235.       {
  236.     char * fmt = (mode == DSP_MODE) ? "%lx" : "#p%lx";
  237.     sprintf(STk_tkbuffer, fmt, (unsigned long) exp->storage_as.env.data);
  238.     Puts(STk_tkbuffer, f);
  239.       }
  240.       break;
  241.     case tc_autoload: /* should never occur!!!!! */
  242.       sprintf(STk_tkbuffer, "#[autoload %lx]", (unsigned long) exp);
  243.       Puts(STk_tkbuffer, f);
  244.       break;
  245.     case tc_Cpointer:
  246.       STk_Cpointer_display(exp, port, mode);
  247.       break;
  248. #ifdef USE_STKLOS
  249.     case tc_instance:
  250.       display_instance(exp, port, mode);
  251.       break;
  252.     case tc_next_method:
  253.       sprintf(STk_tkbuffer, "#[next_method %lx]", (unsigned long) exp);
  254.       Puts(STk_tkbuffer, f);
  255.       break;
  256. #endif
  257. #ifdef USE_TK
  258.     case tc_tkcommand:
  259.       if (mode != TK_MODE) Puts("#[Tk-command ", f);
  260.       Puts(exp->storage_as.tk.data->Id, f);
  261.       if (mode != TK_MODE) Putc(']', f);
  262.       break;
  263. #endif
  264.     case tc_quote:
  265.       Puts("#quote", f);
  266.       break;
  267.     case tc_lambda:
  268.       Puts("#lambda", f); 
  269.       break;
  270.     case tc_if:
  271.       Puts("#if", f); 
  272.       break;
  273.     case tc_setq:
  274.       Puts("#setq", f); 
  275.       break;
  276.     case tc_cond:
  277.       Puts("#cond", f); 
  278.       break;
  279.     case tc_and:
  280.       Puts("#and", f); 
  281.       break;
  282.     case tc_or:
  283.       Puts("#or", f); 
  284.       break;
  285.     case tc_let:
  286.       Puts("#let", f); 
  287.       break;
  288.     case tc_letstar:
  289.       Puts("#let*", f); 
  290.       break;
  291.     case tc_letrec:
  292.       Puts("#letrec", f); 
  293.       break;
  294.     case tc_begin:
  295.       Puts("#begin", f); 
  296.       break;
  297.     case tc_promise:
  298.       sprintf(STk_tkbuffer, "#[promise %lx (%sforced)]", 
  299.                       (unsigned long) exp, 
  300.                       exp->storage_as.promise.resultknown ? "" : "not ");
  301.       Puts(STk_tkbuffer, f);
  302.       break;
  303.     case tc_apply:
  304.       Puts("#apply", f);
  305.       break;
  306.     case tc_call_cc:
  307.       Puts("#call/cc", f);
  308.       break;
  309.     case tc_dynwind:
  310.       Puts("#dynamic-wind", f);
  311.       break;
  312.     case tc_extend_env:
  313.       Puts("#extend-environment", f);
  314.       break;
  315.     case tc_unbound:
  316.       Puts("#[unbound]", f);
  317.       break;
  318.     default:
  319.       if (EXTENDEDP(exp))
  320.     STk_extended_display(exp, port, mode);
  321.       else {
  322.     sprintf(STk_tkbuffer, "#[unknown %d %lx]", TYPE(exp), (unsigned long) exp);
  323.     Puts(STk_tkbuffer, f);
  324.       }
  325.   }
  326.   return UNDEFINED;
  327. }
  328.